home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.003 / stk-3 / stk / 3.1 / STk / stklos.stk < prev    next >
Encoding:
Text File  |  1996-07-29  |  18.3 KB  |  554 lines
  1. ;;;;
  2. ;;;; s t k l o s . s t k    -- A variation of the Gregor Kickzales tiny-clos
  3. ;;;;                  for STk
  4. ;;;;
  5. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6. ;;;; 
  7. ;;;; Permission to use, copy, and/or distribute this software and its
  8. ;;;; documentation for any purpose and without fee is hereby granted, provided
  9. ;;;; that both the above copyright notice and this permission notice appear in
  10. ;;;; all copies and derived works.  Fees for distribution or use of this
  11. ;;;; software or derived works may only be charged with express written
  12. ;;;; permission of the copyright holder.  
  13. ;;;; This software is provided ``as is'' without express or implied warranty.
  14. ;;;;
  15. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  16. ;;;;    Creation date: 20-Feb-1994 21:09
  17. ;;;; Last file update:  1-May-1996 12:13
  18. ;;;;
  19.  
  20. (require "hash")
  21.  
  22. (UNLESS (PROVIDED? "stklos")
  23.   ;; Initialize STklos
  24.   (%init-stklos)
  25.  
  26. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27. ;;;;
  28. ;;;; First define some macros to ease further writing
  29. ;;;;
  30. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31.  
  32. (define (build-scheme-name l)
  33.   (cond
  34.    ((and (list? l) (= (length l) 2) (eq? (car l) 'setter))
  35.                        (string->symbol (format #f "the setter of ~A" (cadr l))))
  36.    ((symbol? l)        l)
  37.    (else            (error "bad Scheme name ~S" l))))
  38.  
  39. (define (build-specializers-list l)
  40.   ;; returns a pair where specializers and parameters are dissociated
  41.   (let loop ((l l) (args '()) (spec '()))
  42.     (cond
  43.      ((pair? l) ;; Something like ((x <integer>) ...) or (z (x <integer>) ...)
  44.              (let ((arg (car l)))
  45.            (if (list? arg)
  46.           (loop (cdr l) (cons (car arg) args) (cons (eval (cadr arg)) spec))
  47.           (loop (cdr l) (cons arg args) (cons <top> spec)))))
  48.      ((null? l) ;; We have finished
  49.              (cons (reverse spec) (reverse args)))
  50.      (else      ;; We have an original list with a "dotted" cdr - i.e (a (b c) . d)
  51.               (cons 
  52.            (append (reverse spec) <top>)
  53.            (append (reverse args) l))))))
  54.  
  55. ;;; Define-class
  56. (define-macro (define-class name supers slots . options)
  57.   `(define ,name
  58.      (make (or ,(get-keyword :metaclass options #f)
  59.            ,(ensure-metaclass (map eval supers)))
  60.        :dsupers ,(if (null? supers)
  61.              `(list <object>)
  62.              `(list ,@supers))
  63.        :slots ',slots
  64.        :name ',name)))
  65.  
  66.  
  67. ;;; Method
  68. (define-macro (method args . body)
  69.   (let ((decomposition (build-specializers-list args)))
  70.     `(make <method>
  71.        :specializers ',(car decomposition)
  72.        :procedure     (lambda (next-method ,@(cdr decomposition))
  73.                ,@body))))
  74.  
  75. ;;; Define-generic
  76. (define-macro (define-generic name . l)
  77.   `(define ,name (apply make <generic> :name ',name ',l)))
  78.  
  79. ;;; Define-method
  80. (define-macro (define-method name args . body)
  81.   (let* ((name     (build-scheme-name name))
  82.      (glob-env (global-environment))
  83.      (previous (if (symbol-bound? name glob-env)
  84.                (eval name glob-env)
  85.                #f))
  86.      (m       (gensym "%M ")))
  87.     `(begin
  88.        (unless (and (symbol-bound? ',name) (is-a? ,name <generic>))
  89.       (define-generic ,name :default ,previous))
  90.        (let ((,m (method ,args ,@body)))
  91.      ;; Set the generic-function slot of the new method
  92.      (slot-set! ,m 'generic-function ,name)
  93.      (add-method ,name ,m))
  94.        ',name)))
  95.  
  96. ;;; is-a?
  97. (define-macro (is-a? obj class)
  98.   `(and (member ,class (class-precedence-list (class-of ,obj))) #t))
  99.  
  100.  
  101. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  102. ;;;;
  103. ;;;; Metaclass utilities
  104. ;;;;
  105. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  106.  
  107. (define (ensure-metaclass supers)
  108.   (if (null? supers) <class>
  109.       (let* ((all-metas (map class-of supers))
  110.          (all-cpls (apply append
  111.                   (map (lambda (m) (cdr (class-precedence-list m))) 
  112.                    all-metas)))
  113.          (needed-metas ()))
  114.     ;; Find the most specific metaclasses.  The new metaclass will be
  115.     ;; a subclass of these.
  116.     (for-each
  117.      (lambda (meta)
  118.        (when (and (not (member meta all-cpls)) (not (member meta needed-metas)))
  119.          (set! needed-metas (append needed-metas (list meta)))))
  120.      all-metas)
  121.     ;; Now return a subclass of the metaclasses we found.
  122.     (if (null? (cdr needed-metas))
  123.         (car needed-metas)  ;; If there's only one, just use it.
  124.         (ensure-metaclass-with-supers needed-metas)))))
  125.  
  126.  
  127. (define ensure-metaclass-with-supers
  128.   (let ((table-of-metas (make-hash-table)))
  129.     (lambda (meta-supers)
  130.       (let* ((name (string->symbol (apply & (map class-name meta-supers))))
  131.          (entry (hash-table-get table-of-metas name #f)))
  132.     (if entry entry
  133.         (let ((new-metaclass (make <class>
  134.                       :dsupers meta-supers
  135.                       :slots ()
  136.                       :name (gensym "metaclass"))))
  137.           (hash-table-put! table-of-metas name new-metaclass)
  138.           new-metaclass))))))
  139.  
  140.  
  141. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  142. ;;;;
  143. ;;;; Utilities
  144. ;;;;
  145. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  146.  
  147. (define (compute-slot-getters class slots)
  148.   (for-each 
  149.       (lambda (s)
  150.     (if (pair? s)
  151.          (let ((getter-name (get-keyword :getter (cdr s) #f)))
  152.            (if getter-name
  153.            (eval `(define-method ,getter-name ((self ,class))
  154.                 (slot-ref self ',(car s))))))))
  155.       slots))
  156.  
  157. (define (compute-slot-setters class slots)
  158.   (for-each
  159.       (lambda (s)
  160.     (if (pair? s)
  161.          (let ((setter-name (get-keyword :setter (cdr s) #f)))
  162.            (if setter-name
  163.            (eval `(define-method ,setter-name ((self ,class) value)
  164.                 (slot-set! self ',(car s) value)))))))
  165.       slots))
  166.  
  167. (define (compute-slot-accessors class slots)
  168.   (for-each
  169.       (lambda (s)
  170.     (if (pair? s)
  171.          (let ((accessor-name (get-keyword :accessor (cdr s) #f)))
  172.            (if accessor-name
  173.            (eval `(begin
  174.                 (define-method ,accessor-name ((self ,class))
  175.                   (slot-ref self ',(car s)))
  176.                 (define-method (setter ,accessor-name) ((self ,class) v)
  177.                   (slot-set! self ',(car s) v))))))))
  178.       slots))
  179.  
  180.  
  181. (define (get-slot-allocation s)
  182.   (if (symbol? s)
  183.       :instance
  184.       (get-keyword :allocation (cdr s) :instance)))
  185.  
  186. ;;;
  187. ;;; compute-getters-n-setters
  188. ;;; 
  189.  
  190. (define (compute-getters-n-setters class slots)
  191.   (map (lambda (s)
  192.      (if (pair? s)
  193.          (cons (car s) (compute-get-n-set class s))
  194.          (cons s       (compute-get-n-set class (list s)))))
  195.        slots))
  196.  
  197.  
  198. ;;;
  199. ;;; compute-cpl
  200. ;;;
  201.  
  202. (define (compute-cpl class)
  203.   
  204.   (define (filter-cpl class)
  205.     (let ((res  '()))
  206.       (for-each (lambda (item)
  207.           (unless (or (eq? item <object>) 
  208.                   (eq? item <top>) 
  209.                   (member item res))
  210.            (set! res (cons item res))))
  211.           class)
  212.       res))
  213.  
  214.   (let* ((supers   (slot-ref class 'direct-supers))
  215.      (big-list (apply append (cons class supers) (map compute-cpl supers))))
  216.     (reverse (list* <top> <object> (filter-cpl big-list)))))
  217.  
  218. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  219. ;;;;
  220. ;;;; Compute-get-n-set
  221. ;;;;
  222. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  223.  
  224. (define-method compute-get-n-set ((class <class>) s)
  225.   (case (get-slot-allocation s)
  226.     (:instance ;; Instance slot
  227.                ;; get-n-set is just its offset
  228.                 (let ((already-allocated (slot-ref class 'nfields)))
  229.          (slot-set! class 'nfields (+ already-allocated 1))
  230.          already-allocated))
  231.  
  232.     (:class  ;; Class slot
  233.              ;; Class-slots accessors are implemented as 2 closures around 
  234.               ;; a Scheme variable. As instance slots, class slots must be
  235.          ;; unbound at init time. Since assignement to an unbound variable 
  236.            ;; is not possible with our set! (in this case set! thinks that
  237.          ;; the variable has not been defined), our variable is in fact 
  238.          ;; a vector of length 1. This permits to circumvent this problem, 
  239.              ;; without introducing a "set-environment" primitive.
  240.              (let ((shared-cell (make-vector 1)))
  241.            (list (lambda (o)   (vector-ref shared-cell 0))
  242.              (lambda (o v) (vector-set! shared-cell 0 v)))))
  243.  
  244.     (:virtual;; No allocation
  245.               ;; slot-ref and slot-set! function must be given by the user
  246.               (let ((get (get-keyword :slot-ref  (cdr s) #f))
  247.            (set (get-keyword :slot-set! (cdr s) #f)))
  248.            (unless (and get set)
  249.           (error "You must supply a :slot-ref and a :slot-set! in ~A" s))
  250.            (list (eval get) 
  251.              (eval set))))
  252.     (else    (error "Allocation \"~S\" is unknown" (get-slot-allocation s)))))
  253.  
  254.  
  255. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  256. ;;;;
  257. ;;;; Initialize
  258. ;;;;
  259. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  260.  
  261. (define-method initialize ((object <object>) initargs)
  262.   (%initialize-object object initargs))
  263.  
  264. (define-method initialize ((class <class>) initargs)
  265.   (next-method)
  266.   (let ((dslots (get-keyword :slots initargs '())))
  267.     (slot-set! class 'name          (get-keyword :name    initargs '???))
  268.     (slot-set! class 'direct-supers     (get-keyword :dsupers initargs '()))
  269.     (slot-set! class 'direct-slots      dslots)
  270.     (slot-set! class 'cpl        (compute-cpl class))
  271.     (let ((slots (%compute-slots class)))
  272.       (slot-set! class 'slots            slots)
  273.       (slot-set! class 'nfields            0)
  274.       (slot-set! class 'initializers      (%compute-initializers slots))
  275.       (slot-set! class 'getters-n-setters (compute-getters-n-setters class slots)))
  276.  
  277.     ;; Build getters - setters - accessors
  278.     (compute-slot-getters   class dslots)
  279.     (compute-slot-setters   class dslots)
  280.     (compute-slot-accessors class dslots)))
  281.  
  282.  
  283. (define-method initialize ((generic <generic>) initargs)
  284.   (let ((previous-definition (get-keyword :default initargs #f)))
  285.     (next-method)
  286.     (slot-set! generic 'name    (get-keyword :name initargs '???))
  287.     (slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
  288.                     (list (make <method>
  289.                         :specializers <top>
  290.                         :procedure 
  291.                             (lambda (nm . l)
  292.                               (apply previous-definition 
  293.                                  l))))
  294.                     ()))))
  295.  
  296. (define-method initialize ((method <method>) initargs)
  297.   (next-method)
  298.   (slot-set! method 'generic-function #f)
  299.   (slot-set! method 'specializers (get-keyword :specializers initargs '()))
  300.   (slot-set! method 'procedure      (get-keyword :procedure initargs (lambda l '()))))
  301.  
  302. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  303. ;;;;
  304. ;;;; Allocate-instance
  305. ;;;;
  306. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  307.  
  308. (define-method allocate-instance ((class <class>) initargs)
  309.   (%allocate-instance class))
  310.  
  311. (define-method make-instance ((class <class>) initargs)
  312.   (let ((instance (allocate-instance class initargs)))
  313.     (initialize instance initargs)
  314.     instance))
  315.  
  316. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  317. ;;;;
  318. ;;;; Make. 
  319. ;;;;
  320. ;;;; A new definition which overwrite the previous one which was built-in
  321. ;;;;
  322. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  323.  
  324. (define (MAKE class . initargs)
  325.   (make-instance class initargs))
  326.  
  327. ;;;;
  328. ;;;; Protocol for calling standard generic functions. 
  329. ;;;; This protocol is not used for real <generic> function (in this case
  330. ;;;; we use a completly C hard-coded protocol).
  331. ;;;; The method apply-generic is called by the interpreter when a subclass
  332. ;;;; of <generic> is applied.
  333. ;;;;
  334. (define-method apply-generic ((gf <generic>) args)
  335.   ;; Verify that this function has associated methods
  336.   (if (null? (slot-ref gf 'methods))
  337.       (no-method gf args))
  338.   
  339.   (let ((applicable (apply find-method gf args)))
  340.     (if applicable
  341.     (let* ((methods (sort-applicable-methods gf applicable args))
  342.            (procs   (map (lambda (x) (slot-ref x 'procedure)) methods)))
  343.       ;; Call the first applicable method
  344.       (letrec ((next (lambda (procs args)
  345.                (lambda new-args
  346.                  (let ((a (if (null? new-args) args new-args)))
  347.                    (if (null? procs)
  348.                    (no-next-method gf a)
  349.                    (apply (car procs)
  350.                       (next (cdr procs) a)
  351.                       a)))))))
  352.         (apply (car procs) (next (cdr procs) args) args)))
  353.     ;; No applicable method
  354.     (no-applicable-method gf args))))
  355.  
  356. (define-method sort-applicable-methods ((gf <generic>) methods args)
  357.   (let ((targs (map class-of args)))
  358.     (sort methods (lambda (m1 m2) (method-more-specific? m1 m2 targs)))))
  359.  
  360. (define-method method-more-specific? ((m1 <method>) (m2 <method>) targs)
  361.   (%method-more-specific? m1 m2 targs))
  362.  
  363. ;;;;
  364. ;;;; Methods for the possible error we can encounter when calling a gf
  365. ;;;;
  366.  
  367. (define-method no-next-method ((gf <generic>) args)
  368.   (error "No next method when calling ~S (name=~S) with ~S as argument" 
  369.      gf (slot-ref gf 'name) args))
  370.  
  371. (define-method no-applicable-method ((gf <generic>) args)
  372.   (error "No applicable method for ~S\nin call ~S" 
  373.      gf (append (cons (slot-ref gf 'name) args))))
  374.  
  375. (define-method no-method ((gf <generic>) args)
  376.   (error "No method defined for ~S (name=~S)"  gf (slot-ref gf 'name)))
  377.  
  378.  
  379. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  380. ;;;;
  381. ;;;; Change-class
  382. ;;;;
  383. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  384.  
  385. (define-method change-class ((old-instance <object>) (new-class <class>))
  386.   (let ((new-instance (allocate-instance new-class ()))
  387.     (old-slots    (map (lambda (x) (if (pair? x) (car x) x)) 
  388.                (class-slots (class-of old-instance)))))
  389.     ;; Set all the common slots to their old value
  390.     (for-each (lambda (slot)
  391.         (if (and (slot-exists? new-instance slot)
  392.              (slot-bound? old-instance slot))
  393.             (slot-set! new-instance slot (slot-ref old-instance slot))))
  394.           old-slots)
  395.     (%modify-instance old-instance new-instance)))
  396.  
  397.  
  398. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  399. ;;;;
  400. ;;;; Clone functions (from rdeline@CS.CMU.EDU)
  401. ;;;;
  402. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  403.  
  404. (define-method shallow-clone ((self <object>))
  405.   (let ((clone (%allocate-instance (class-of self)))
  406.     (slots (map (lambda (x) (if (pair? x) (car x) x)) 
  407.             (class-slots (class-of self)))))
  408.     (for-each (lambda (slot)
  409.         (if (slot-bound? self slot)
  410.             (slot-set! clone slot
  411.                    (slot-ref self slot))))
  412.           slots)
  413.     clone))
  414.  
  415. (define-method deep-clone ((self <object>))
  416.   (let ((clone (%allocate-instance (class-of self)))
  417.     (slots (map (lambda (x) (if (pair? x) (car x) x)) 
  418.             (class-slots (class-of self)))))
  419.     (for-each (lambda (slot)
  420.         (if (slot-bound? self slot)
  421.             (slot-set! clone slot
  422.                    (let ((value (slot-ref self slot)))
  423.                  (if (instance? value)
  424.                      (deep-clone value)
  425.                      value)))))
  426.           slots)
  427.     clone))
  428.  
  429. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  430. ;;;;
  431. ;;;; method-body
  432. ;;;;
  433. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  434.  
  435. (define-method method-body ((self <method>))
  436.   (let* ((spec (map class-name (slot-ref self 'specializers)))
  437.      (proc (procedure-body (slot-ref self 'procedure)))
  438.      (args (cdadr proc))
  439.      (body (cddr proc)))
  440.     (list* 'method (map list args spec) body)))
  441.  
  442. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  443. ;;;;
  444. ;;;; <Composite-metaclass> metaclass
  445. ;;;; 
  446. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  447.  
  448. (define-class <Composite-metaclass> (<class>)
  449.   ())
  450.  
  451. (define-method compute-get-n-set ((class <Composite-metaclass>) slot)
  452.   (if (memv (get-slot-allocation slot) '(:propagated :special))
  453.       (compute-propagated-get-n-set slot)
  454.       (next-method)))
  455.  
  456. (define (compute-propagated-get-n-set s)
  457.   (let ((prop       (or (get-keyword :propagate-to  (cdr s) #f)
  458.                 (get-keyword :propagate     (cdr s) #f)))
  459.     (s-name       (car s))
  460.     (build-reader   (lambda (s default)
  461.               (unless (pair? s) (set! s (list s default)))
  462.               `(slot-ref (slot-ref o ',(car s)) ',(cadr s))))
  463.     (build-writer    (lambda (s default)
  464.               (unless (pair? s) (set! s (list s default)))
  465.               `(slot-set! (slot-ref o ',(car s)) ',(cadr s) v))))
  466.  
  467.     (unless prop (error "Propagation not specified for slot ~s" s-name))
  468.     (unless (pair? prop) (error "Bad propagation list for slot ~s" s-name))
  469.  
  470.     (list 
  471.        ;; The getter
  472.        (eval `(lambda (o) ,(build-reader (car prop) s-name)))
  473.        ;; The setter
  474.        (eval `(lambda (o v)
  475.         ,@(map (lambda (item) (build-writer item s-name))
  476.                prop))))))
  477.  
  478. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  479. ;;;;
  480. ;;;; Methods to compare objects
  481. ;;;;
  482. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  483. (define-method object-eqv? (x y)
  484.   #f)
  485.  
  486. (define-method object-equal? (x y)
  487.   #f)
  488.  
  489. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  490. ;;;;
  491. ;;;; Methods to display/write an object
  492. ;;;;
  493. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  494.  
  495. ;;; Write
  496. (define-method write-object (o file)
  497.   (format file "#[~A ~A]" (class-name (class-of o)) (address-of o)))
  498.  
  499. (define-method write-object((self <class>) file)
  500.    (format file "#[~A ~A]" (class-name (class-of self)) 
  501.                   (class-name self)))
  502.  
  503. (define-method write-object((self <generic>) file)
  504.   (format file "#[~A ~A]" (class-name (class-of self)) 
  505.                 (slot-ref self 'name)))
  506.  
  507. ;;; Display (do the same thing as write by default)
  508. (define-method display-object (o file) 
  509.   (write-object o file))
  510.  
  511. ;;; Tk-write-object is called when a STklos object is passed to a Tk-command.
  512. ;;; By default, we do the same job as write; but if an object is a <Tk-widget>
  513. ;;; we will pass it its Eid. The method for <Tk-widget> is defined elsewhere.
  514. (define-method Tk-write-object (o file)
  515.   (write-object o file))
  516.  
  517. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  518. ;;;;
  519. ;;;; Dylan Setters.
  520. ;;;;
  521. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  522.  
  523. (define %syntax-set!     set!)
  524. (define %syntax-define     define)
  525. (define %dylan-setters    'initialized)
  526.  
  527. (define-macro (setter var)
  528.   (let ((x (build-scheme-name `(setter ,var))))
  529.     `(if (symbol-bound? ',x)
  530.      ,x
  531.      (error "setter of ~s is undefined" ',var))))
  532.  
  533. (define-macro (define var . val)
  534.   (when (null? val) (error "define: no value provided for ~A" var))
  535.   (if (and (pair? var) (eqv? (car var) 'setter))
  536.       `(%syntax-define ,(build-scheme-name var) ,@val)
  537.       `(%syntax-define ,var ,@val)))
  538.  
  539. (define-macro (set! var val)
  540.   (if (list? var) 
  541.       `(,(build-scheme-name `(setter ,(car var))) ,@(cdr var) ,val)
  542.       `(%syntax-set! ,(build-scheme-name var) ,val)))
  543.  
  544. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  545. ;;;;
  546. ;;;; Backward compatibility
  547. ;;;;
  548. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  549.  
  550. (define class-cpl class-precedence-list)
  551.  
  552. (provide "stklos")
  553. )
  554.